home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Graphics Plus
/
Graphics Plus.iso
/
msdos
/
raytrace
/
pov
/
gen
/
treebas
/
trees1.bas
< prev
Wrap
BASIC Source File
|
1993-06-12
|
38KB
|
1,077 lines
'trees1.bas by ed smith
'slightly edited by taudas@ais.org 6/93
DECLARE SUB poly (pl1!(), pl2!(), pl3!(), sc!)
DECLARE SUB polygon ()
DECLARE SUB branchman ()
DECLARE SUB tropisim ()
DECLARE SUB stack (stype$)
DECLARE SUB turtle (filename$)
DECLARE SUB rotateX ()
DECLARE SUB widthman ()
DECLARE SUB rotateU ()
DECLARE SUB rotateL ()
DECLARE SUB rotateH ()
DECLARE SUB trans3d2d ()
DECLARE SUB drawline ()
DECLARE SUB movef (c$)
DECLARE SUB number2string (anumber AS DOUBLE)
DECLARE SUB getparams (place AS DOUBLE)
DECLARE SUB string2num (ntemp$)
DECLARE SUB productions (filename$, iterations AS INTEGER)
DECLARE SUB convst (tnumber!, lead!)
DECLARE SUB handler (c$, place AS DOUBLE)
DECLARE SUB f (place AS DOUBLE)
DECLARE SUB sf (place AS DOUBLE)
DECLARE SUB A (place AS DOUBLE)
DECLARE SUB B (place AS DOUBLE)
DECLARE SUB cC (place AS DOUBLE)
DECLARE SUB D (place AS DOUBLE)
DECLARE SUB RU (place AS DOUBLE)
DECLARE SUB RL (place AS DOUBLE)
DECLARE SUB RH (place AS DOUBLE)
DECLARE SUB decr (place AS DOUBLE)
DECLARE SUB colour (place AS DOUBLE)
DECLARE SUB normal (c$, place AS DOUBLE)
DECLARE SUB powercon (power!, temp$)
DIM SHARED numberarray(1, 12)
DIM SHARED branch(8, 3)
DIM SHARED XOO, YOO, ZOO
DIM SHARED anumber AS DOUBLE, number$
DIM SHARED wid AS DOUBLE
DIM SHARED STAC(25, 25) AS DOUBLE
DIM SHARED POINTER, stype$
DIM SHARED fpos
DIM SHARED a0 AS DOUBLE, a2 AS DOUBLE, ds AS DOUBLE, r1 AS DOUBLE, r2 AS DOUBLE
DIM SHARED wr AS DOUBLE
DIM SHARED h(3) AS DOUBLE, l(3) AS DOUBLE, u(3) AS DOUBLE, V(3) AS DOUBLE
DIM SHARED hp(3) AS DOUBLE, lp(3) AS DOUBLE, up(3) AS DOUBLE
DIM SHARED xs, ys, zs, th, phi, xso, yso, zso
DIM SHARED xo, yo, zo
DIM SHARED place AS DOUBLE
DIM SHARED t(3) AS DOUBLE
DIM SHARED code
DIM SHARED pi AS DOUBLE
DIM SHARED scale
DIM SHARED atemp
DIM SHARED x, y, z
DIM SHARED e AS DOUBLE
scale = 40
V(1) = 0
V(2) = .2
V(3) = 1
h(3) = 1
u(1) = -1
u(3) = 0
l(2) = -1
pi = 3.141592
th = pi / 4
phi = 90 * pi / 180
'default values
'a0 = pi / 6
'a2 = pi / (22 / 180)
'r1 = .9
'r2 = .7
'Here are some values to try :
r1 = .9: r2 = .97: a0 = pi / 5: a2 = pi / 5
' r1 = .9: r2 = .6: a0 = pi / 4: a2 = pi / 4
' r1 = 0.9: r2 = 0.9: a0 = pi/4: a2 = pi/4
' r1 = 0.9: r2 = 0.8: a0 = pi/4: a2 = pi/4
' r1 = .9: r2 = .7: a0 = pi / 6: a2 = -pi / 6
'this l-system was lifted out of the Alogorithmic Beauty of Plants. Ed
ds = 137.5 * 3.14 / 180
wr = .707
SCREEN 12
code = 1
CALL productions("test", 5)
t(1) = 0: t(2) = 0: t(3) = -1
e = .3
OPEN "points.raw" FOR OUTPUT AS #255
CALL turtle("commands.raw")
CLOSE #255
CALL polygon
SUB A (place AS DOUBLE)
CALL getparams(place)
w = numberarray(1, 3)
l = numberarray(1, 2)
anumber = w
CALL number2string(anumber)
ws$ = number$
anumber = l
CALL number2string(anumber)
ls$ = number$
anumber = l * r2
CALL number2string(anumber)
lXr2$ = number$
anumber = w * wr
CALL number2string(anumber)
wXwr$ = number$
anumber = l * r1
CALL number2string(anumber)
lXr1$ = number$
anumber = a0
CALL number2string(anumber)
a0w$ = number$
anumber = -a2
CALL number2string(anumber)
a2w$ = number$
anumber = ds
CALL number2string(anumber)
dw$ = number$
write$ = "!(" + ws$ + ")F(" + ls$ + ")[&(" + a0w$ + ")B(" + lXr2$ + "," + wXwr$ + ")]/(" + dw$ + ")A(" + lXr1$ + "," + wXwr$ + ")"
PRINT #2, write$;
END SUB
SUB B (place AS DOUBLE)
CALL getparams(place)
w = numberarray(1, 3)
l = numberarray(1, 2)
anumber = w
CALL number2string(anumber)
ws$ = number$
anumber = l
CALL number2string(anumber)
ls$ = number$
anumber = l * r2
CALL number2string(anumber)
lXr2$ = number$
anumber = w * wr
CALL number2string(anumber)
wXwr$ = number$
anumber = l * r1
CALL number2string(anumber)
lXr1$ = number$
anumber = a0
CALL number2string(anumber)
a0w$ = number$
anumber = -a2
CALL number2string(anumber)
a2w$ = number$
anumber = ds
CALL number2string(anumber)
dw$ = number$
write$ = "!(" + ws$ + ")F(" + ls$ + ")[+(" + a2w$ + ")$C(" + lXr2$ + "," + wXwr$ + ")]C(" + lXr1$ + "," + wXwr$ + ")"
PRINT #2, write$;
END SUB
SUB branchman
DIM bpoint(3)
DIM bpointp(3)
DIM utem(3)
utem(1) = u(1)
utem(2) = u(2)
utem(3) = u(3)
IF utem(1) = 0 AND utem(2) = 0 AND utem(3) = 0 THEN PRINT "ouchie!"
IF l(1) = 0 AND l(2) = 0 AND l(3) = 0 THEN PRINT "louchie!"
sind = SIN(pi / 4): cosd = COS(pi / 4)
bpoint(1) = l(1)
bpoint(2) = l(2)
bpoint(3) = l(3)
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(1, 1) = bpoint(1) * wid
branch(1, 2) = bpoint(2) * wid
branch(1, 3) = bpoint(3) * wid
LOCATE 1, 1
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(2, 1) = bpoint(1) * wid
branch(2, 2) = bpoint(2) * wid
branch(2, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(3, 1) = bpoint(1) * wid
branch(3, 2) = bpoint(2) * wid
branch(3, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(4, 1) = bpoint(1) * wid
branch(4, 2) = bpoint(2) * wid
branch(4, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(5, 1) = bpoint(1) * wid
branch(5, 2) = bpoint(2) * wid
branch(5, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(6, 1) = bpoint(1) * wid
branch(6, 2) = bpoint(2) * wid
branch(6, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(7, 1) = bpoint(1) * wid
branch(7, 2) = bpoint(2) * wid
branch(7, 3) = bpoint(3) * wid
bpointp(1) = bpoint(1) * cosd + u(1) * sind
bpointp(2) = bpoint(2) * cosd + u(2) * sind
bpointp(3) = bpoint(3) * cosd + u(3) * sind
up(1) = -bpoint(1) * sind + u(1) * cosd
up(2) = -bpoint(2) * sind + u(2) * cosd
up(3) = -bpoint(3) * sind + u(3) * cosd
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
bpoint(1) = bpointp(1)
bpoint(2) = bpointp(2)
bpoint(3) = bpointp(3)
branch(8, 1) = bpoint(1) * wid
branch(8, 2) = bpoint(2) * wid
branch(8, 3) = bpoint(3) * wid
u(1) = utem(1)
u(2) = utem(2)
u(3) = utem(3)
FOR bpnum = 1 TO 8
WRITE #255, branch(bpnum, 1) + XOO * scale, branch(bpnum, 2) + YOO * scale, branch(bpnum, 3) + ZOO * scale
WRITE #255, branch(bpnum, 1) + x * scale, branch(bpnum, 2) + y * scale, branch(bpnum, 3) + z * scale
NEXT bpnum
END SUB
SUB cC (place AS DOUBLE)
CALL getparams(place)
w = numberarray(1, 3)
l = numberarray(1, 2)
anumber = w
CALL number2string(anumber)
ws$ = number$
anumber = l
CALL number2string(anumber)
ls$ = number$
anumber = l * r2
CALL number2string(anumber)
lXr2$ = number$
anumber = w * wr
CALL number2string(anumber)
wXwr$ = number$
anumber = l * r1
CALL number2string(anumber)
lXr1$ = number$
anumber = a0
CALL number2string(anumber)
a0w$ = number$
anumber = a2
CALL number2string(anumber)
a2w$ = number$
anumber = ds
CALL number2string(anumber)
dw$ = number$
write$ = "!(" + ws$ + ")F(" + ls$ + ")[+(" + a2w$ + ")$B(" + lXr2$ + "," + wXwr$ + ")]B(" + lXr1$ + "," + wXwr$ + ")"
PRINT #2, write$;
END SUB
SUB colour (place AS DOUBLE)
PRINT #2, "'";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB convst (tnumber, lead)
IF tnumber = 1 THEN
number$ = number$ + "1"
ELSEIF tnumber = 2 THEN number$ = number$ + "2"
ELSEIF tnumber = 3 THEN number$ = number$ + "3"
ELSEIF tnumber = 4 THEN number$ = number$ + "4"
ELSEIF tnumber = 5 THEN number$ = number$ + "5"
ELSEIF tnumber = 6 THEN number$ = number$ + "6"
ELSEIF tnumber = 7 THEN number$ = number$ + "7"
ELSEIF tnumber = 8 THEN number$ = number$ + "8"
ELSEIF tnumber = 9 THEN number$ = number$ + "9"
ELSEIF tnumber = 0 AND lead = 0 THEN number$ = number$ + "0"
END IF
END SUB
SUB D (place AS DOUBLE)
PRINT #2, "D";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB decr (place AS DOUBLE)
PRINT #2, "!";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB drawline
CALL trans3d2d
xs = 320 + (xs * scale): xso = 320 + (xso * scale)
ys = 400 - (ys * scale): yso = 400 - (yso * scale)
LINE (xs, ys)-(xso, yso), code
END SUB
SUB f (place AS DOUBLE)
PRINT #2, "F";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB getparams (place AS DOUBLE)
numberarray(1, 1) = 1
fpos = SEEK(1)
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
IF c$ = "," THEN numberarray(1, 1) = numberarray(1, 1) + 1
LOOP
SEEK #1, fpos
FOR counter = 1 TO numberarray(1, 1)
ntemp$ = ""
c$ = INPUT$(1, #1)
DO UNTIL c$ = "," OR c$ = ")"
IF c$ <> "," AND c$ <> "(" AND c$ <> ")" THEN
ntemp$ = ntemp$ + c$
END IF
c$ = INPUT$(1, #1)
LOOP
CALL string2num(ntemp$)
numberarray(1, counter + 1) = atemp
NEXT counter
fpos = SEEK(1) + 1
END SUB
SUB handler (c$, place AS DOUBLE)
REM *** Detect type of command and pass control ***
REM ***possible candidates for context matching
REM and parameter checks ***
IF c$ = "F" THEN
CALL f(place)
ELSEIF c$ = "f" THEN CALL sf(place)
ELSEIF c$ = "A" THEN CALL A(place)
ELSEIF c$ = "B" THEN CALL B(place)
ELSEIF c$ = "C" THEN CALL cC(place)
ELSEIF c$ = "D" THEN CALL D(place)
ELSEIF c$ = "+" THEN CALL RU(place)
ELSEIF c$ = "&" THEN CALL RL(place)
ELSEIF c$ = "/" THEN CALL RH(place)
ELSEIF c$ = "!" THEN CALL decr(place)
ELSEIF c$ = "'" THEN CALL colour(place)
REM ***Add your own as long as no other keywords ***
REM ****
REM *** All other commands goto the normal handler ***
ELSE CALL normal(c$, place)
END IF
END SUB
SUB movef (c$)
cOM$ = c$
kplace = SEEK(1)
CALL getparams(place)
x = numberarray(1, 2) * h(1) + xo
y = numberarray(1, 2) * h(2) + yo
z = numberarray(1, 2) * h(3) + zo
IF cOM$ = "F" THEN CALL drawline
XOO = xo
YOO = yo
ZOO = zo
xo = x
yo = y
zo = z
SEEK #1, kplace
CALL branchman
CALL tropisim
END SUB
SUB normal (c$, place AS DOUBLE)
IF c$ <> "]" AND c$ <> "[" AND c$ <> "$" THEN
DO UNTIL c$ = ")" OR EOF(1) <> 0
c$ = INPUT$(1, #1)
place = place + 1
PRINT #2, c$;
LOOP
END IF
END SUB
SUB number2string (anumber AS DOUBLE)
REM *** get rid of sign for later use***
sign$ = ""
IF anumber < 0 THEN
atnumber = ABS(anumber)
anumber = atnumber
sign$ = "-"
END IF
hnumber = FIX(anumber)
REM ***Find number of leading zeros in fractional part of anumber***
s = 0
frnumber = (anumber - hnumber)
DO WHILE frnumber <> FIX(frnumber)
s = s + 1
frnumber = (anumber - hnumber) * 10 ^ s
LOOP
s = s - 1
number$ = sign$: REM *** place the sign into leading part of string ***
REM *** convert hnumber -> number$ ***
lead = 1
FOR i = 10 TO 0 STEP -1
tnumber = FIX(hnumber / (10 ^ i))
IF tnumber > 0 THEN lead = 0
CALL convst(tnumber, lead)
hnumber = hnumber - tnumber * 10 ^ i
NEXT i
REM ***Dont forget the fractional part!!***
number$ = number$ + "."
lead = 0
FOR i = s TO 0 STEP -1
tnumber = FIX(frnumber / (10 ^ i))
CALL convst(tnumber, lead)
frnumber = frnumber - tnumber * 10 ^ i
NEXT i
END SUB
SUB poly (pl1(), pl2(), pl3(), sc)
xs1 = -pl1(1) * SIN(th) + pl1(2) * COS(th)
ys1 = -pl1(1) * COS(th) * COS(phi) - pl1(2) * SIN(th) * COS(phi) + pl1(3) * SIN(phi)
xs2 = -pl2(1) * SIN(th) + pl2(2) * COS(th)
ys2 = -pl2(1) * COS(th) * COS(phi) - pl2(2) * SIN(th) * COS(phi) + pl2(3) * SIN(phi)
xs3 = -pl3(1) * SIN(th) + pl3(2) * COS(th)
ys3 = -pl3(1) * COS(th) * COS(phi) - pl3(2) * SIN(th) * COS(phi) + pl3(3) * SIN(phi)
LINE (320 + xs1 * sc, 400 - ys1 * sc)-(320 + xs2 * sc, 400 - ys2 * sc), 1
LINE (320 + xs2 * sc, 400 - ys2 * sc)-(320 + xs3 * sc, 400 - ys3 * sc), 2
LINE (320 + xs3 * sc, 400 - ys3 * sc)-(320 + xs1 * sc, 400 - ys1 * sc), 3
END SUB
SUB polygon
INPUT "Scale: ", sc
CLS
DIM p1(3)
DIM p2(3)
DIM p3(3)
DIM p4(3)
DIM p5(3)
DIM p6(3)
DIM p7(3)
DIM p8(3)
DIM p9(3)
DIM p10(3)
DIM p11(3)
DIM p12(3)
DIM p13(3)
DIM p14(3)
DIM p15(3)
DIM p16(3)
OPEN "points.raw" FOR INPUT AS #255
OPEN "tree.txt" FOR OUTPUT AS #254
DO WHILE EOF(255) = 0
INPUT #255, p1(1), p1(2), p1(3)
INPUT #255, p2(1), p2(2), p2(3)
INPUT #255, p3(1), p3(2), p3(3)
INPUT #255, p4(1), p4(2), p4(3)
INPUT #255, p5(1), p5(2), p5(3)
INPUT #255, p6(1), p6(2), p6(3)
INPUT #255, p7(1), p7(2), p7(3)
INPUT #255, p8(1), p8(2), p8(3)
INPUT #255, p9(1), p9(2), p9(3)
INPUT #255, p10(1), p10(2), p10(3)
INPUT #255, p11(1), p11(2), p11(3)
INPUT #255, p12(1), p12(2), p12(3)
INPUT #255, p13(1), p13(2), p13(3)
INPUT #255, p14(1), p14(2), p14(3)
INPUT #255, p15(1), p15(2), p15(3)
INPUT #255, p16(1), p16(2), p16(3)
q$ = ""
PRINT #254, USING "####.######"; p1(1); p1(2); p1(3); p2(1); p2(2); p2(3); p15(1); p15(2); p15(3)
CALL poly(p1(), p2(), p15(), sc)
PRINT #254, USING "####.######"; p15(1); p15(2); p15(3); p16(1); p16(2); p16(3); p2(1); p2(2); p2(3)
CALL poly(p15(), p16(), p2(), sc)
PRINT #254, USING "####.######"; p15(1); p15(2); p15(3); p16(1); p16(2); p16(3); p13(1); p13(2); p13(3)
CALL poly(p15(), p16(), p13(), sc)
PRINT #254, USING "####.######"; p13(1); p13(2); p13(3); p14(1); p14(2); p14(3); p16(1); p16(2); p16(3)
CALL poly(p13(), p14(), p16(), sc)
PRINT #254, USING "####.######"; p13(1); p13(2); p13(3); p14(1); p14(2); p14(3); p11(1); p11(2); p11(3)
CALL poly(p13(), p14(), p11(), sc)
PRINT #254, USING "####.######"; p11(1); p11(2); p11(3); p12(1); p12(2); p12(3); p14(1); p14(2); p14(3)
CALL poly(p11(), p12(), p14(), sc)
PRINT #254, USING "####.######"; p11(1); p11(2); p11(3); p12(1); p12(2); p12(3); p9(1); p9(2); p9(3)
CALL poly(p11(), p12(), p9(), sc)
PRINT #254, USING "####.######"; p9(1); p9(2); p9(3); p10(1); p10(2); p10(3); p12(1); p12(2); p12(3)
CALL poly(p9(), p10(), p12(), sc)
PRINT #254, USING "####.######"; p9(1); p9(2); p9(3); p10(1); p10(2); p10(3); p7(1); p7(2); p7(3)
CALL poly(p9(), p10(), p7(), sc)
PRINT #254, USING "####.######"; p7(1); p7(2); p7(3); p8(1); p8(2); p8(3); p10(1); p10(2); p10(3)
CALL poly(p7(), p8(), p10(), sc)
PRINT #254, USING "####.######"; p7(1); p7(2); p7(3); p8(1); p8(2); p8(3); p5(1); p5(2); p5(3)
CALL poly(p7(), p8(), p5(), sc)
PRINT #254, USING "####.######"; p5(1); p5(2); p5(3); p6(1); p6(2); p6(3); p8(1); p8(2); p8(3)
CALL poly(p5(), p6(), p8(), sc)
PRINT #254, USING "####.######"; p5(1); p5(2); p5(3); p6(1); p6(2); p6(3); p3(1); p3(2); p3(3)
CALL poly(p5(), p6(), p3(), sc)
PRINT #254, USING "####.######"; p3(1); p3(2); p3(3); p4(1); p4(2); p4(3); p6(1); p6(2); p6(3)
CALL poly(p3(), p4(), p6(), sc)
PRINT #254, USING "####.######"; p3(1); p3(2); p3(3); p4(1); p4(2); p4(3); p1(1); p1(2); p1(3)
CALL poly(p3(), p4(), p1(), sc)
PRINT #254, USING "####.######"; p1(1); p1(2); p1(3); p2(1); p2(2); p2(3); p4(1); p4(2); p4(3)
CALL poly(p1(), p2(), p4(), sc)
LOOP
CLOSE #255
PRINT #254, " "
CLOSE #254
END SUB
SUB powercon (power, temp$) STATIC
tenmul = 10 ^ power
IF temp$ = "1" THEN
atemp = atemp + tenmul
ELSEIF temp$ = "2" THEN atemp = atemp + 2 * tenmul
ELSEIF temp$ = "3" THEN atemp = atemp + 3 * tenmul
ELSEIF temp$ = "4" THEN atemp = atemp + 4 * tenmul
ELSEIF temp$ = "5" THEN atemp = atemp + 5 * tenmul
ELSEIF temp$ = "6" THEN atemp = atemp + 6 * tenmul
ELSEIF temp$ = "7" THEN atemp = atemp + 7 * tenmul
ELSEIF temp$ = "8" THEN atemp = atemp + 8 * tenmul
ELSEIF temp$ = "9" THEN atemp = atemp + 9 * tenmul
END IF
END SUB
SUB productions (filename$, iterations AS INTEGER)
REM *** Production City ****
OPEN filename$ FOR INPUT AS #1
REM *** Copy contents of the Axiom file into a temp file ***
OPEN "temp1" FOR OUTPUT AS #2
DO WHILE EOF(1) = 0
char$ = INPUT$(1, #1)
PRINT #2, char$;
LOOP
CLOSE #1, #2
REM *** Open files temp1 and temp2 for productions ***
REM *** Start Loop for the productions on file temp1 ***
FOR i = 1 TO iterations
LOCATE 1, 1
PRINT i
OPEN "temp1" FOR INPUT AS #1
OPEN "temp2" FOR OUTPUT AS #2
place = 1
DO WHILE EOF(1) = 0
c$ = INPUT$(1, #1)
REM ***check for non parameter symbols***
IF c$ = "]" THEN
PRINT #2, "]";
ELSEIF c$ = "[" THEN PRINT #2, "[";
ELSEIF c$ = "$" THEN PRINT #2, "$";
END IF
place = place + 1
CALL handler(c$, place)
LOOP
CLOSE #1, #2
REM *** copy contents of temp2 to temp1 for next iteration***
OPEN "temp1" FOR OUTPUT AS #1
OPEN "temp2" FOR INPUT AS #2
DO WHILE EOF(2) = 0
char$ = INPUT$(1, #2)
PRINT #1, char$;
LOOP
CLOSE #1, #2
NEXT i
REM *** copy contents of temp2 to commands.raw for turtle ***
OPEN "commands.raw" FOR OUTPUT AS #1
OPEN "temp2" FOR INPUT AS #2
DO WHILE EOF(2) = 0
char$ = INPUT$(1, #2)
PRINT #1, char$;
LOOP
CLOSE #1, #2
END SUB
SUB recalcU
END SUB
SUB RH (place AS DOUBLE)
PRINT #2, "/";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB RL (place AS DOUBLE)
PRINT #2, "&";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB rotateH
kplace = SEEK(1)
CALL getparams(place)
deg = numberarray(1, 2)
cosd = COS(deg)
sind = SIN(deg)
REM *H*
hp(1) = h(1)
hp(2) = h(2)
hp(3) = h(3)
REM *L*
lp(1) = l(1) * cosd + u(1) * sind
lp(2) = l(2) * cosd + u(2) * sind
lp(3) = l(3) * cosd + u(3) * sind
REM *U*
up(1) = -l(1) * sind + u(1) * cosd
up(2) = -l(2) * sind + u(2) * cosd
up(3) = -l(3) * sind + u(3) * cosd
u(1) = up(1): h(1) = hp(1): l(1) = lp(1)
u(2) = up(2): h(2) = hp(2): l(2) = lp(2)
u(3) = up(3): h(3) = hp(3): l(3) = lp(3)
IF h(1) = 0 AND h(2) = 0 AND h(3) = 0 THEN PRINT : PRINT "Error": END
SEEK #1, kplace
END SUB
SUB rotateL
kplace = SEEK(1)
CALL getparams(place)
deg = numberarray(1, 2)
cosd = COS(deg)
sind = SIN(deg)
REM *H*
hp(1) = h(1) * cosd + u(1) * sind
hp(2) = h(2) * cosd + u(2) * sind
hp(3) = h(3) * cosd + u(3) * sind
REM *L*
lp(1) = l(1)
lp(2) = l(2)
lp(3) = l(3)
REM *U*
up(1) = -h(1) * sind + u(1) * cosd
up(2) = -h(2) * sind + u(2) * cosd
up(3) = -h(3) * sind + u(3) * cosd
u(1) = up(1): h(1) = hp(1): l(1) = lp(1)
u(2) = up(2): h(2) = hp(2): l(2) = lp(2)
u(3) = up(3): h(3) = hp(3): l(3) = lp(3)
SEEK #1, kplace
IF h(1) = 0 AND h(2) = 0 AND h(3) = 0 THEN PRINT : PRINT "Error": END
END SUB
SUB rotateU
kplace = SEEK(1)
CALL getparams(place)
deg = numberarray(1, 2)
cosd = COS(deg)
sind = SIN(deg)
REM *H*
hp(1) = h(1) * cosd - l(1) * sind
hp(2) = h(2) * cosd - l(2) * sind
hp(3) = h(3) * cosd - l(3) * sind
REM *L*
lp(1) = h(1) * sind + l(1) * cosd
lp(2) = h(2) * sind + l(2) * cosd
lp(3) = h(3) * sind + l(3) * cosd
REM *U*
up(1) = u(1)
up(2) = u(2)
up(3) = u(3)
u(1) = up(1): h(1) = hp(1): l(1) = lp(1)
u(2) = up(2): h(2) = hp(2): l(2) = lp(2)
u(3) = up(3): h(3) = hp(3): l(3) = lp(3)
IF h(1) = 0 AND h(2) = 0 AND h(3) = 0 THEN PRINT : PRINT "Error": END
SEEK #1, kplace
END SUB
SUB rotateX
' This sub rolls the turtle around it's axis
' so that L pointing to the left of the turtle
' is brought to a horizontal position according to the
' formula: V X H
' L = ------- then U = H X L
' |V X H|
' where V is the vector pointing opposite to that of gravity
DIM VXH(3)
VXH(1) = V(2) * h(3) - V(3) * h(2)
VXH(2) = V(3) * h(1) - V(1) * h(3)
VXH(3) = V(1) * h(2) - V(2) * h(1)
length = SQR((VXH(1)) ^ 2 + (VXH(2)) ^ 2 + (VXH(3)) ^ 2)
l(1) = VXH(1) / length
l(2) = VXH(2) / length
l(3) = VXH(3) / length
u(1) = h(2) * l(3) - h(3) * l(2)
u(2) = h(3) * l(1) - h(1) * l(3)
u(3) = h(1) * l(2) - h(2) * l(1)
IF u(1) = 0 AND u(2) = 0 AND u(3) = 0 THEN PRINT "ouch!"
END SUB
SUB RU (place AS DOUBLE)
PRINT #2, "+";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB sf (place AS DOUBLE)
PRINT #2, "f";
DO UNTIL c$ = ")"
c$ = INPUT$(1, #1)
PRINT #2, c$;
place = place + 1
LOOP
END SUB
SUB stack (stype$)
IF stype$ = "push" THEN
POINTER = POINTER + 1
STAC(1, POINTER) = h(1): STAC(2, POINTER) = h(2): STAC(3, POINTER) = h(3)
STAC(4, POINTER) = l(1): STAC(5, POINTER) = l(2): STAC(6, POINTER) = l(3)
STAC(7, POINTER) = u(1): STAC(8, POINTER) = u(2): STAC(9, POINTER) = u(3)
STAC(10, POINTER) = x: STAC(11, POINTER) = y: STAC(12, POINTER) = z
STAC(13, POINTER) = xo: STAC(14, POINTER) = yo: STAC(15, POINTER) = zo
STAC(16, POINTER) = code: STAC(17, POINTER) = diam
STAC(18, POINTER) = wid: STAC(19, POINTER) = deg
STAC(20, POINTER) = XOO
STAC(21, POINTER) = YOO
STAC(22, POINTER) = ZOO
END IF
IF stype$ = "pull" THEN
h(1) = STAC(1, POINTER): h(2) = STAC(2, POINTER): h(3) = STAC(3, POINTER)
l(1) = STAC(4, POINTER): l(2) = STAC(5, POINTER): l(3) = STAC(6, POINTER)
u(1) = STAC(7, POINTER): u(2) = STAC(8, POINTER): u(3) = STAC(9, POINTER)
x = STAC(10, POINTER): y = STAC(11, POINTER): z = STAC(12, POINTER):
xo = STAC(13, POINTER): yo = STAC(14, POINTER): zo = STAC(15, POINTER):
code = STAC(16, POINTER): diam = STAC(17, POINTER)
wid = STAC(18, POINTER): deg = STAC(19, POINTER)
XOO = STAC(20, POINTER)
YOO = STAC(21, POINTER)
ZOO = STAC(22, POINTER)
POINTER = POINTER - 1
END IF
END SUB
SUB string2num (ntemp$)
atemp = 0
REM *** get sign ***
mult = 1
IF MID$(ntemp$, 1, 1) = "-" THEN
mult = -1
antemp$ = MID$(ntemp$, 2)
ntemp$ = antemp$
END IF
REM *** Find decimal point ***
DO WHILE temp$ <> "."
t = t + 1
temp$ = MID$(ntemp$, t, 1)
nplace = nplace + 1
IF t > LEN(ntemp$) THEN temp$ = ".": nplace = LEN(ntemp$) + 1
LOOP
nplace = nplace - 1
REM *** Get first number ***
power = 0
FOR t = nplace TO 1 STEP -1
temp$ = MID$(ntemp$, t, 1)
CALL powercon(power, temp$)
power = power + 1:
NEXT t
nplace = nplace + 2
power = -1
FOR t = nplace TO LEN(ntemp$)
temp$ = MID$(ntemp$, t, 1)
CALL powercon(power, temp$)
power = power - 1
NEXT t
atemp = atemp * mult
END SUB
SUB trans3d2d
xs = -x * SIN(th) + y * COS(th)
ys = -x * COS(th) * COS(phi) - y * SIN(th) * COS(phi) + z * SIN(phi)
xso = -xo * SIN(th) + yo * COS(th)
yso = -xo * COS(th) * COS(phi) - yo * SIN(th) * COS(phi) + zo * SIN(phi)
END SUB
SUB tropisim
DIM hxt(3) AS DOUBLE
hxt(1) = (h(2) * t(3) - h(3) * t(2))
hxt(2) = (h(3) * t(1) - h(1) * t(3))
hxt(3) = (h(1) * t(2) - h(2) * t(1))
factor = SQR(hxt(1) ^ 2 + hxt(2) ^ 2 + hxt(3) ^ 2)
IF factor <> 0 THEN
xr = hxt(1) / factor
yr = hxt(2) / factor
zr = hxt(3) / factor
tl = SQR(t(1) ^ 2 + t(2) ^ 2 + t(3) ^ 2)
arg = factor / tl
asin = arg + (arg ^ 3) / 6 + (3 * arg ^ 5) / 40 + (15 * arg ^ 7) / 336
sr = SIN(arg * e)
cr = COS(arg * e)
tr = 1 - COS(arg * e)
REM *** rotate h ***
hp(1) = h(1) * (tr * xr ^ 2 + cr) + h(2) * (tr * xr * yr - sr * zr) + h(3) * (tr * xr * zr + sr * yr)
hp(2) = h(1) * (tr * xr * yr + sr * zr) + h(2) * (tr * yr ^ 2 + cr) + h(3) * (tr * yr * zr - sr * xr)
hp(3) = h(1) * (tr * xr * zr - sr * yr) + h(2) * (tr * yr * zr + sr * xr) + h(3) * (tr * zr ^ 2 + cr)
REM ***rotate l***
lp(1) = l(1) * (tr * xr ^ 2 + cr) + l(2) * (tr * xr * yr - sr * zr) + l(3) * (tr * xr * zr + sr * yr)
lp(2) = l(1) * (tr * xr * yr + sr * zr) + l(2) * (tr * yr ^ 2 + cr) + l(3) * (tr * yr * zr - sr * xr)
lp(3) = l(1) * (tr * xr * zr - sr * yr) + l(2) * (tr * yr * zr + sr * xr) + l(3) * (tr * zr ^ 2 + cr)
REM ***rotate u***
up(1) = u(1) * (tr * xr ^ 2 + cr) + u(2) * (tr * xr * yr - sr * zr) + u(3) * (tr * xr * zr + sr * yr)
up(2) = u(1) * (tr * xr * yr + sr * zr) + u(2) * (tr * yr ^ 2 + cr) + u(3) * (tr * yr * zr - sr * xr)
up(3) = u(1) * (tr * xr * zr - sr * yr) + u(2) * (tr * yr * zr + sr * xr) + u(3) * (tr * zr ^ 2 + cr)
h(1) = hp(1)
h(2) = hp(2)
h(3) = hp(3)
l(1) = lp(1)
l(2) = lp(2)
l(3) = lp(3)
u(1) = up(1)
u(2) = up(2)
u(3) = up(3)
END IF
END SUB
SUB turtle (filename$)
OPEN filename$ FOR INPUT AS #1
DO WHILE EOF(1) = 0
c$ = INPUT$(1, #1)
IF c$ = "f" OR c$ = "F" THEN
CALL movef(c$)
ELSEIF c$ = "A" THEN
code = 2
ELSEIF c$ = "B" THEN
code = 3
ELSEIF c$ = "C" THEN
code = 4
ELSEIF c$ = "+" THEN
CALL rotateU
ELSEIF c$ = "&" THEN
CALL rotateL
ELSEIF c$ = "/" THEN
CALL rotateH
ELSEIF c$ = "$" THEN
CALL rotateX
ELSEIF c$ = "!" THEN
CALL widthman
ELSEIF c$ = "]" THEN
stype$ = "pull"
CALL stack(stype$)
ELSEIF c$ = "[" THEN
stype$ = "push"
CALL stack(stype$)
REM ELSEIF c$ = "'" THEN
REM CALL colortable
END IF
LOOP
END SUB
SUB widthman
kplace = SEEK(1)
CALL getparams(place)
wid = numberarray(1, 2)
SEEK #1, kplace
END SUB